Language/OS - Multiplatform Resource Library/LANGUAGE OS.iso/self/contrib.lha/contrib/491/aa/boites.self

Text File | 1993-07-13 | 20.5 KB | 794 lines

" Implementation of graphics boxes (a la TeX) for Self"

"
*
* boites.self,v 1.17 1993/07/13 21:46:58 richards Exp
*
* /home/2user2/richards/cvs/491/aa/boites.self,v 1.17 1993/07/13 21:46:58 richards Exp
* *Header: /home/14user1/richards/RCS/boites.self,v 1.5 1992/09/23 18:56:59 richards Exp richards *
*
* boites.self,v
* Revision 1.17  1993/07/13  21:46:58  richards
* July 13 checkin.
*
* Revision 1.16  1993/06/24  21:24:30  richards
* Split drawing out of boites and into light weight views.
*
* Revision 1.15  1993/06/23  21:18:07  richards
* Daily checkin.
*
* Revision 1.14  1993/06/23  02:04:21  richards
* Progress towards being able to select equations.
*
* Revision 1.13  1993/06/23  00:36:04  richards
* Fixed up test1 to work with new code.
* boites and window have first hack at highlighting code.
*
* Revision 1.12  1993/06/21  21:39:22  richards
* Added highlighting.
* Moved gc cache into viewManager.
*
* Revision 1.11  1993/06/18  21:25:36  richards
* Moved font support into viewManager.
* Starting to add selection stuff into window and boite.
* Boites refer properly back to the polynomial structures.
*
* Revision 1.10  1993/05/31  20:27:50  richards
* symbols has the whole greek alphabet, but some letters are not named right.
* window.self now uses two sub-classes of compoundView, one inside the other.
* (Still have problem identifying them...)
* test7 obsolete.
* Fixed some problems with font positioning in boites and poly.
*
* Revision 1.9  1993/05/31  00:12:10  richards
* May 30 checkin. Font support is nearly debugged.
* Make use of glue now.
* Added rational (fraction) types.
*
* Revision 1.8  1993/05/30  21:41:14  richards
*  Starting to add font support to text boites.
*
* Revision 1.7  1993/05/23  23:16:47  richards
* New X library drawing primitives incorporated.
* Limited font support. (Gets the sizes wrong)
* expandSubBoites written, and working.
*
# Revision 1.6  1993/05/14  22:35:54  richards
# Full use of bnum class is now implemented, and proper copying of
# objects is now done.
#
# Revision 1.5  1992/09/23  18:56:59  richards
# This is very strange. Self appears to not accept multiple arguments to a
# block, and I seem to have no idea how to declare local variables within a
# block without introducing a sub-block.
# Attempt at a work-around.
#
# Revision 1.4  1992/09/08  02:09:45  richards
# Added makeRequiredSizes for the vboite and hboite. expandSubBoites is a
# nifty problem though since the Scheme code has a nice accessor function.
# Perhaps we really do need a (x,posy,negy) object. Hmm. Ponder.
# Probably.
#
# Revision 1.3  1992/08/19  02:41:41  richards
# Added fixUpSizes to start the TeX glue algorithm.
#
*
*
"

aa _AddSlotsIfAbsent: (| boites = () |)

aa boites _AddSlotsIfAbsent: (|
    traits=().
    prototypes* = ().
    mixins=().
|)

aa boites traits _AddSlotsIfAbsent: (|
    proto_boite=().
    hboite = ().
    vboite = ().
    htext  = ().
    vtext  = ().
    glueboite = ().
    hglue  = ().
    vglue  = ().
    hline  = ().
    vline  = ().
|)

aa boites prototypes _AddSlotsIfAbsent: (|
    proto_boite=().
    hboite = ().
    vboite = ().
    htext  = ().
    vtext  = ().
    hglue  = ().
    vglue  = ().
    hline  = ().
    vline  = ().
|)

aa boites mixins _AddSlotsIfAbsent: (|
    containerboite = ().
    textboite      = ().
|)

" NOTES ON COORDINATES
  ********************

  - There is a transition occuring between referring to SIZES as x/y
to now using x/y for position and xSize/ySize for this function.
width/height are not isomorphic, as width is a bnum, but height is
posy+negy.
  - there are three coordinates: width, upheight and downheight. That
is, there is a definite baseline to which objects are relative to.
  - Sizes upwards are downwards are always positive!
  - y coordinates go from top->bottom
  - x coordinates go from left->right

"

aa boites traits proto_boite _Define: (|
    parent* = traits clonable.
    identityness** = mixins identity.

    copy = ( | new. |
    new: clone.
    new width: width copy.
    new upheight: upheight copy.
    new downheight: downheight copy.
    ^new).
    x    =      ( width value ).   " depreciated "
    xSize =     ( width value ).
    posy =      ( upheight value ).   " depreciated "
    upY  =      ( upheight value ).
    negy =      ( downheight value ).  " depreciated "
    downY =     ( downheight value ).
    x: val =    ( width value: val ).  " depreciated "
    xSize: val = ( width value: val ).
    posy: val = ( upheight value: val).  " depreciated "
    negy: val = ( downheight value: val).  " depreciated "
    boiteType = 'unknown'.
    sizeString  = ( ' [',
        width value printString,',',
        upheight value printString,'/',
        downheight value printString,']').
    printString = ( 'An ' , boiteType, sizeString ).

    setMinSizes = (
    x: width lower.
    posy: upheight lower.
    negy: downheight lower.
    ^self).

    fixUpSizes  = ( setMinSizes. ).
    height      = ( posy + negy ).
    ySize       = ( posy + negy ).
    extent      = ( xSize@@ySize ).


    makeRequiredSizes = (
    setMinSizes.
    fixUpSizes.
    makeRequiredSizes: x PosY: posy NegY: negy.
    ).

    makeRequiredSizes: xSize PosY: yPosSize NegY: yNegSize = (
"    ('Setting ',printString,' to ',xSize printString,',',yPosSize printString,'/',yNegSize printString) printLine."
    x: xSize.
    posy: yPosSize.
    negy: yNegSize.
    ).

    " No default. "
    fixUpFonts: win = ( ^self ).

    "This property should be set if a vboite should consider the"
    "vertical center of the boite as its vertical center (baseline)"
    vboiteCenters = false.

    " The following booleans are used by parts of the system to make decisions "
    " that can't be encoded in the object hierarchy via message sends "
    " This implements a kind of `isKindOf' "
    vboite = false.
    hboite = false.
    htext  = false.
    vtext  = false.
    hglue  = false.
    vglue  = false.
    hline  = false.
    vline  = false.

    " Actually, any code that really wants to work right, should test for "
    " specific capabilities, so provide some defaults. "
    vexpandable = false.
    hexpandable = false.

    defaultPolyObject: po = (
    polyObject isNil ifTrue: [ polyObject: po ].
    ).

    bbox = ((0@(posy negate))#(xSize@negy)).

    contains: aBoite = (
    (aBoite == self)
    ).

    " follows the boite structure upwards until a different polyObject is seen"
    upPolyObject = (| up. |
    up: self.
    [(up isNil not) && [up polyObject = polyObject]] whileTrue: [ up: up containedIn ].
    up
    ).

    " follows the boite structure upwards while we see the same polyObject "
    canonicalPolyObject = (| up. last. |
    up: self.
    last: up.
    [(up isNil not) && [up polyObject = polyObject]] whileTrue: [ last: up. up: up containedIn ].
    last
    ).


    " perform block only for things with no substructure "
    leafsDo: aBlock = (
    aBlock value: self
    ).

|)

aa boites mixins containerboite _Define: (|
    copy    = (| new |
    new: resend.copy.
    new contents: contents copy.
    ^new
    ).
    printString = (| str. |
    str: 'An ',boiteType,sizeString,' containing: \n'.
    contents do: [ | :aThing |
        str: str, '\t', aThing printString, '\n'.
    ].
    ^str
    ).
    addEnd:   thing = (
    contents addLast: thing.
    thing defaultPolyObject: polyObject.
    thing containedIn: self.
    thing.
    ).
    addBegin: thing = (
    contents addFirst: thing.
    thing defaultPolyObject: polyObject.
    thing containedIn: self.
    thing.
    ).

    " setMinSizes "
    setMinSizes = (
    contents do: [ | :aThing |
        aThing setMinSizes.
    ].
    ).

    expandSubBoites: expandList From: oldSize To: newSize ChangeBlock: expandBlock FetchBlock: curSizeBlock =
    (| sizeChange. expandBit. |
    sizeChange: newSize - oldSize.
    ((sizeChange > 0) && [expandList nonEmpty]) ifTrue: [
        expandBit: sizeChange /+ expandList size.
        expandList do: [| :aSubBoite |
        (sizeChange != 0) ifTrue: [
            expandBlock value: aSubBoite
            With: ((curSizeBlock value: aSubBoite) + expandBit).
            sizeChange: sizeChange - expandBit.
        ].
        ].
    ].
    ).

    fixUpFonts: aview = (
    contents do: [| :aThing |
"        ('Fixing up:',aThing printString) printLine."
        aThing fixUpFonts: aview.
    ].
    ).

    bbox = (| bb. |
    bb: rectangle copy.
    contents do: [| :aThing |
        bb: bb union: aThing bbox.
    ].
    bb
    ).
    contains: aBoite = (
    (aBoite == self) ifTrue: [ ^true ].
    contents do: [| :aThing |
        (aThing contains: aBoite) ifTrue: [ ^true ].
    ].
    ^false
    ).
    leafsDo: aBlock = (
    contents do: [| :aThing. |
        aThing leafsDo: aBlock
    ].
    ).
|)

aa boites traits hboite _Define: (|
    proto_parent** = aa boites traits proto_boite.
    contentparent* = aa boites mixins containerboite.
    boiteType = 'hboite'.
    hboite    = true.
    hexpandable = true.

    createLWViewOn: win At: aPoint = ( | curx. cury. |
    curx: aPoint x.
    cury: aPoint y.
    contents do: [ | :aThing |
        aThing createLWViewOn: win At: (curx@cury).
        curx: curx + aThing xSize.
    ]
    ).

    " fixUpSizes propagates the minimum and maximum  "
    " sizes up from the bottom level boxes and makes "
    " the v and h-boxes the appropriate sizes        "
    fixUpSizes      = ( | sum. newPosY. newNegY. |
    sum: 0.
    newPosY: 0.
    newNegY: 0.

    "NOTE: The scheme code did this in four seperate loops"
    contents do: [ | :aSubBoite |
        " First, fix up sub-boxes "
        aSubBoite fixUpSizes.

        " Now set adjust size of container "
        sum: sum + aSubBoite x.
        newPosY: newPosY max: aSubBoite posy.
        newNegY: newNegY max: aSubBoite negy.
    ].
    posy: newPosY.
    negy: newNegY.
    x: sum.
    ).

    makeRequiredSizes: xSize PosY: yPosSize NegY: yNegSize = (| expandableXThings. newPosY. newNegY. curXSize. expandBit. sizeChange. |
    expandableXThings: list copy.
    contents do: [| :aSubBoite |
        aSubBoite hexpandable ifTrue: [
        expandableXThings add: aSubBoite.
        ] False: [
        aSubBoite makeRequiredSizes: (aSubBoite x) PosY: yPosSize NegY: yNegSize.
        ].
    ].

    expandSubBoites: expandableXThings From: x To: xSize
        ChangeBlock: [| :aSubBoite. :desiredSize |
            aSubBoite makeRequiredSizes: desiredSize
           PosY: (aSubBoite posy)
           NegY: (aSubBoite negy). ]
        FetchBlock: [| :aSubBoite. |
            aSubBoite x    ].

    newPosY: 0. newNegY: 0.
    contents do: [ | :aSubBoite |
        " Now set adjust size of container "
        newPosY: newPosY max: aSubBoite posy.
        newNegY: newNegY max: aSubBoite negy.
    ].
    posy: newPosY.
    negy: newNegY.
    )
|)

aa boites traits vboite _Define: (|
    proto_parent** = aa boites traits proto_boite.
    contentparent* = aa boites mixins containerboite.
    boiteType = 'vboite'.
    vboite    = true.
    vexpandable = true.

    createLWViewOn: win At: aPoint = ( | curx. cury. |
    curx: aPoint x.
    cury: aPoint y - posy.
    contents do: [ | :aThing |
        cury: cury + aThing posy.
"        ('drawing: ',aThing printString,' at ',curx printString,'@',cury printString) printLine."
        aThing createLWViewOn: win At: (curx@cury).
        cury: cury + aThing negy.
    ]
    ).

    " fixUpSizes propagates the minimum and maximum  "
    " sizes up from the bottom level boxes and makes "
    " the v-boxes the appropriate sizes        "
    " The vboite version does some additional work the hboite "
    " one does not need. It attempts to divide the the vertical "
    " box into two parts --- the part above the hline (if any) "
    " and the part below it. The two sizes become the pos/neg y "
    " sizes. "

    fixUpSizes      = ( | xWidth. above. yHeight. |
    xWidth: x.
    above: true.
    yHeight: 0.
    contents do: [ | :aSubBoite |
        " First, fix up sub-boxes "
        aSubBoite fixUpSizes.

        " Now set adjust size of container "
        xWidth: xWidth max: aSubBoite x.

        ((aSubBoite == baseLineBoite) && above) ifTrue: [
        above: false.
        yHeight: yHeight + aSubBoite posy.
        posy: yHeight.
        yHeight: aSubBoite negy.
        ] False: [
        yHeight: yHeight + aSubBoite height.
        ].

    ].
    x: xWidth.
    above ifTrue: [
        posy: yHeight.
        negy: 0.
    ] False: [
        negy: yHeight.
    ].
    ).

    " Make required size's job is to expand the glue and sub-container types "
    " so that they fill/fit in the available space. This code is translated "
    " from the Scheme, although oop reorganizes it a bit. "
    " With full font support it should be possible to make even more "
    " complicated decisions "
    " XXX --- this code does not at present pay attention to baselines "
    "    in a vboite! "

    makeRequiredSizes: xSize PosY: yPosSize NegY: yNegSize = (| expandableYThings. newWidth. baseline. |
    expandableYThings: list copy.

    contents do: [ | :aSubBoite |
        aSubBoite vexpandable ifTrue: [
        expandableThings add: aSubBoite.
        ] False: [
        aSubBoite makeRequiredSizes: xSize PosY: (aSubBoite posy) NegY: (aSubBoite negy).
        ].
    ].

    expandSubBoites: expandableYThings From: posy To: yPosSize
        ChangeBlock: [| :aSubBoite. :desiredSize |
            aSubBoite makeRequiredSizes: xSize
           PosY: desiredSize
           NegY: (aSubBoite negy). ]
        FetchBlock: [| :aSubBoite. |
            aSubBoite posy    ].

    newWidth: 0.
    baseline: 0.
    contents do: [ | :aSubBoite |
        " Now set adjust size of container "
        newWidth: newWidth max: aSubBoite x.
        baseline: baseline + aSubBoite posy.
        (aSubBoite == baseLineBoite) ifTrue: [
        upheight value: baseline.
        baseline: 0.
        ].
        baseline: baseline + aSubBoite negy.
    ].
    downheight value: baseline.
    x: newWidth.
    ).
|)

aa boites mixins textboite _Define: (|
    " should eventually pick the smallest font. "

    setMinSizes = ().
    fixUpSizes  = ().
    setText: someText = (
    text: someText.
    calculateSizes.
    ).

    creating* = (|
    make: someText = (|new|
        new: copy.
        new setText: someText.
        new
    ).

    roman: string = ( | b. |
        b: copy.
        b fontPrefix: '-*-helvetica-medium-r-normal-*-'.
        b setText: string.
        ^b
    ).
    italic: string = ( | b. |
        b: copy.
        b fontPrefix: '-*-helvetica-medium-o-normal-*-'.
        b setText: string.
        ^b
    ).
    symbol: string = ( | b. |
        b: copy.
        b fontPrefix: '-*-symbol-medium-r-normal-*-'.
        b setText: string.
        ^b
    ).
    |).

|)

aa boites traits htext _Define: (|
    proto_parent** = aa boites traits proto_boite.
    htext_parent*  = aa boites mixins textboite.

    copy    = (|new|
    new: proto_parent.copy.
    allowedFontSizes: allowedFontSizes copy.
    ^new
    ).
    boiteType = 'htext'.

    smallestFontSize = ( allowedFontSizes first ).
    largestFontSize  = ( allowedFontSizes last  ).
    _ calculateSizes = (| len. |
    len: text size.
    upheight lower: 0.
    upheight value: curFontSize.
    downheight lower: 0.
    downheight value: 0.
    width lower: 0.
    width value: curFontSize * len.
    curFontName: (fontPrefix,curFontSize printString, fontSuffix).
    self
    ).
    printString = ( |str|
    str: 'An htext containing: \'',text,'\'',sizeString.
    ^str
    ).
    createLWViewOn: vue At: aPoint = (| nv. |
    nv: aa views boiteView copyForBoite: self At: aPoint.
    vue addSubView: nv.
    vue boiteSubViews at: self Put: nv.
    ).

    drawOn: vue At: aPoint = (
    vue drawAt: aPoint
          String:  text
          InFontNamed: curFontName
    ).

    fixUpFonts: view = (| fontStruct. |
    fontStruct: view openFontNamed: curFontName.
    width value: fontStruct xTextWidth: text.
    upheight value: fontStruct ascent.
    downheight value: fontStruct descent.
    ).
|)

" VTEXT NOT YET IMPLEMENTED! "
aa boites traits vtext _Define: (|
    proto_parent* = aa boites traits proto_boite.
    copy    = (|new|
    new: proto_parent.copy.
    allowedFontSizes: allowedFontSizes copy.
    new
    ).
    make: someText = (|new|
    new: copy.
    new setText: someText.
    new
    ).
    setText: someText = (
        text: someText.
    calculateSizes.
    ).
    setBaseline: base = (
    baseline: base.
    calculateSizes.
    ).

    smallestFontSize = ( allowedFontSizes first ).
    largestFontSize  = ( allowedFontSizes last  ).
    calculateSizes = ( | len. uplen. downlen. |
    len:  text size.
    width lower: smallestFontSize.
    width upper: largestFontSize.
    width value: curFontSize.
    uplen: len - baseline.
    downlen: baseline.
    upheight lower: smallestFontSize * uplen.
    upheight upper: largestFontSize * uplen.
    upheight value: curFontSize * uplen.
    downheight lower: smallestFontSize * uplen.
    downheight upper: largestFontSize * uplen.
    downheight value: curFontSize * uplen.
    curFontName: (fontPrefix,curFontSize printString, fontSuffix).
    ).
    printString = ( | str. |
    str: 'A vtext containing:"',text,'"',sizeString.
    ^str
    ).
|)

aa boites traits glueboite _Define: (|
   proto_parent** = aa boites traits proto_boite.
    createLWViewOn: view At: pt = ( self ).  " glue is invisible "
    copy    = (| new. |
    new: proto_parent.copy.
    new width lower: 0.
    new upheight lower: 0.
    new downheight lower: 0.
    ^new
    ).
|)

aa boites traits hglue _Define: (|
    glue_parent*   = aa boites traits glueboite.
    hexpandable    = true.
    boiteType      = 'HGlue'.
|)

aa boites traits vglue _Define: (|
    glue_parent*   = aa boites traits glueboite.
    vexpandable    = true.
    boiteType      = 'VGlue'.
|)

aa boites traits hline _Define: (|
    proto_parent* = aa boites traits proto_boite.
    copy    = (| new. |
    new: proto_parent.copy.
    new calculateThickness.
    ^new
    ).
    calculateThickness = (
    upheight lower: thickness.
    upheight upper: thickness.
    downheight lower: thickness.
    downheight upper: thickness.
    upheight value: 0.
    downheight value: 0.

    width lower: thickness * 4.
    width upper: infinity.
    width value: 0.
    ).
    thickness: thick = (
    iThickness: thick.
    calculateThickness.
    ^self
    ).
    thickness = ( iThickness ).
    boiteType = 'HLine'.
    vboiteCenters = true.

    drawing* = (|
    createLWViewOn: vue At: pt = (
        vue addSubView: aa views boiteView copyForBoite: self At: pt.
    ).

    drawOn: vue At: pt = (
        vue drawFrom: pt For: ((width value)@0)
    ).
    |).
|)

aa boites traits vline _Define: (|
    proto_parent* = aa boites traits proto_boite.
    copy    = (|new|
    new: proto_parent.copy.
    new calculateThickness.
    ^new
    ).
    calculateThickness = (
    upheight lower: thickness.
    downheight lower: thickness.
    width lower: thickness.
    width upper: thickness.

    upheight value: thickness.
    downheight value: thickness.
    width value: thickness.
    ).
    thickness: thick = (
    iThickness: thick.
    calculateThickness.
    ^self
    ).
    thickness = ( iThickness ).
    boiteType = 'VLine'.
    drawing* = (|
    createLWViewOn: vue At: pt = (
        " set width! "
        vue addSubView: aa views boiteView copyForBoite: self At: aPoint.
    ).

    drawOn: vue At: pt = (| xHalf. |
        xHalf: (pt x) + (xSize / 2).
        vue drawFrom: xHalf@(pt y - (upheight value)) To: xHalf@(pt y + (downheight value))
    ).
    |).
|)


"
*            *
* PROTOTYPES *
*            *
"

aa boites prototypes proto_boite _Define: (|
    width <- aa bnum copy.
    upheight <- aa bnum copy.
    downheight <- aa bnum copy.
    polyObject.
    containedIn.
    thisObjectPrints = true.
|)

aa boites prototypes hboite _Define: aa boites prototypes proto_boite
aa boites prototypes hboite _AddSlots: (|
    parent* = aa boites traits hboite.
    "_" contents <- list copy.
|)

aa boites prototypes vboite _Define: aa boites prototypes proto_boite
aa boites prototypes vboite _AddSlots: (|
    parent* = aa boites traits vboite.
    "_" contents <- list copy.
    ^ baseLineBoite <- nil.
|)

aa boites prototypes htext _Define: aa boites prototypes proto_boite
aa boites prototypes htext _AddSlots: (|
    parent* = aa boites traits htext.
    text <- ''.
    curFontName.
    allowedFontSizes <- list copy add: 24.
    fontPrefix <- '-*-Courier-medium-r-*-*-'.
    curFontSize <- 24.
    fontSuffix <- '-*-*-*-*-*-*-*'.
|)

aa boites prototypes vtext _Define: aa boites prototypes proto_boite
aa boites prototypes vtext _AddSlots: (|
    parent* = aa boites traits vtext.
    text <- ''.
    baseline <- 0.
    curFontName.
    allowedFontSizes <- list copy add: 24.
    fontPrefix <- '-*-Courier-medium-r-*-*-'.
    curFontSize <- 24.
    fontSuffix <- '-*-*-*-*-*-*-*'.
|)

aa boites prototypes hglue _Define: aa boites prototypes proto_boite
aa boites prototypes hglue _AddSlots: (|
    parent* = aa boites traits hglue.
|)

aa boites prototypes vglue _Define: aa boites prototypes proto_boite
aa boites prototypes vglue _AddSlots: (|
    parent* = aa boites traits vglue.
|)

aa boites prototypes hline _Define: aa boites prototypes proto_boite
aa boites prototypes hline _AddSlots: (|
    parent* = aa boites traits hline.
    iThickness <- 2.
|)

aa boites prototypes vline _Define: aa boites prototypes proto_boite
aa boites prototypes vline _AddSlots: (|
    parent* = aa boites traits vline.
    iThickness <- 1.
|)